home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCsiod / sources / repl2.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-01  |  7.5 KB  |  226 lines
  1. /* Scheme In One Define.
  2.  
  3. The garbage collector, the name and other parts of this program are
  4.  
  5.  *                     COPYRIGHT (c) 1989 BY                              *
  6.  *      PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  7.  
  8. Conversion  to  full scheme standard, characters, vectors, ports, complex &
  9. rational numbers, and other major enhancments by
  10.  
  11.  *      Scaglione Ermanno, v. Pirinoli 16 IMPERIA P.M. 18100 ITALY        * 
  12.  
  13. Permission  to use, copy, modify, distribute and sell this software and its
  14. documentation  for  any purpose and without fee is hereby granted, provided
  15. that  the  above  copyright  notice appear in all copies and that both that
  16. copyright   notice   and   this  permission  notice  appear  in  supporting
  17. documentation,  and that the name of Paradigm Associates Inc not be used in
  18. advertising or publicity pertaining to distribution of the software without
  19. specific, written prior permission.
  20.  
  21. PARADIGM  DISCLAIMS  ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  22. ALL  IMPLIED  WARRANTIES  OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  23. PARADIGM  BE  LIABLE  FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  24. ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
  25. IN  AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
  26. OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  27.  
  28. */
  29.  
  30. #include <stdio.h>
  31. #include <string.h>
  32. #include <ctype.h>
  33. #include <setjmp.h>
  34. #include <signal.h>
  35. #include <time.h>
  36. #include <math.h>
  37.  
  38. #include "siod.h"
  39.  
  40. void process_cla(int argc, char **argv)
  41. {int k;
  42.  for(k=1;k<argc;++k)
  43.    {if (strlen(argv[k])<2) continue;
  44.     if (argv[k][0] != '-')
  45.       {printf("bad arg: %s\n",argv[k]);continue;}
  46.     switch(argv[k][1])
  47.       {case 'h':
  48.      heap_size = atol(&(argv[k][2]));
  49.          if(heap_size<1000)
  50.         heap_size = 1000;
  51.          break;
  52.        case 'o':
  53.      obarray_dim = atol(&(argv[k][2])); 
  54.          if(obarray_dim<1)
  55.            obarray_dim=1;
  56.          break;
  57.        case 'f':
  58.      fixarray_dim = atol(&(argv[k][2])); 
  59.          if(fixarray_dim<1)
  60.            fixarray_dim=1;
  61.          break;
  62.        case 'i':
  63.      init_file = &(argv[k][2]); break;
  64.        case 'q':
  65.      quiet = 1;
  66.          break;
  67.        case 's':
  68.      full_set = 0; break;
  69.        default: printf("bad arg: %s\n",argv[k]);exit(10);}}}
  70.  
  71. void print_welcome(void)
  72. {printf("\f           SSSSSSSSSS       IIII       OOOOOOOO        DDDDD \n");
  73.  printf("          SSSSSSSSSSSS      IIII      OOOOOOOOOO       DDDDDD \n");
  74.  printf("         SSSS              IIII      OOOO   OOOO      DDDDDDDD\n");
  75.  printf("        SSSS              IIII      OOOO    OOOO      DDDD  DDDD\n");
  76.  printf("        SSSSSSSSSSS       IIII      OOOO    OOOO      DDDD   DDDD\n");
  77.  printf("         SSSSSSSSSSS     IIII      OOOO    OOOO      DDDD    DDDD\n");
  78.  printf("               SSSS      IIII      OOOO    OOOO      DDDD    DDDD\n");
  79.  printf("              SSSS      IIII       OOOO   OOOO      DDDD    DDDD\n");
  80.  printf("      SSSSSSSSSSS      IIII        OOOOOOOOOO      DDDDDDDDDDDD\n");
  81.  printf("     SSSSSSSSSSS       IIII         OOOOOOOO      DDDDDDDDDDDD\n\n");
  82.  printf("                       Scheme In One Define.\n");
  83.  printf("             Based on the original code from Paradigm Inc.\n"); 
  84.  printf("                       Coded by E. Scaglione\n");
  85.  printf("                           Version 2.6\n\n");
  86. }
  87.  
  88. void print_hs_1(void)
  89. {printf("Heap size is %d cells, %d bytes.\n",
  90.         heap_size,heap_size*sizeof(struct obj));
  91.  printf("Symbol hash table size is %d buckets, %d bytes.\n",
  92.         obarray_dim,obarray_dim*sizeof(struct obj *));
  93.  printf("Integers hash table size is %d buckets, %d bytes.\n",
  94.         fixarray_dim,fixarray_dim*sizeof(struct obj *));
  95.  printf("Loaded a %s set of predefined functions\n",full_set?"full":"small");
  96.  printf("Mode: %s\n",quiet ? "silent":"verbose");}
  97.  
  98. long no_interrupt(long n)
  99. {long x;
  100.  x = nointerrupt;
  101.  nointerrupt = n;
  102.  if ((nointerrupt == 0) && (interrupt_differed == 1))
  103.    {interrupt_differed = 0;
  104.     err_ctrl_c();}
  105.  return(x);}
  106.  
  107. void handle_sigfpe(int sig)
  108. {signal(SIGFPE,handle_sigfpe);
  109.  err("floating point exception",NIL,ERR_GEN);}
  110.  
  111. #ifdef AMIGA
  112.  
  113. void handle_sigabort(int sig)
  114. {signal(SIGABRT,handle_sigabort);
  115.  err("abnormal termination",NIL,ERR_GEN);}
  116.  
  117. void _CXOVF()
  118. {raise(SIGABRT);}
  119.  
  120. #endif
  121.  
  122. void handle_sigint(int sig)
  123. {signal(SIGINT,handle_sigint);
  124.  if (nointerrupt == 1)
  125.    interrupt_differed = 1;
  126.  else
  127.    err_ctrl_c();}
  128.  
  129. void err_ctrl_c(void)
  130. {err("control-c interrupt",NIL,ERR_GEN);}
  131.  
  132. LISP eof_valp(LISP x)
  133. {if(EQ(x,eof_val))
  134.    return(truth);
  135.  return(NIL);}
  136.  
  137. void err(char *message, LISP x, int type)
  138. {FILE *out;
  139.  if(type & ERR_FIRST)
  140.    sprintf(tkbuffer,"ERROR: 1st arg to %s",message);
  141.  else if(type & ERR_SECOND)
  142.    sprintf(tkbuffer,"ERROR: 2nd arg to %s",message);
  143.  else if(type & ERR_THIRD)
  144.    sprintf(tkbuffer,"ERROR: 3rd arg to %s",message);
  145.  else if(type & ERR_GEN_ARG)
  146.    sprintf(tkbuffer,"ERROR: arg to %s",message);
  147.  if((type & ERR_GEN)||(type & ERR_MEM))
  148.    sprintf(tkbuffer,"ERROR: %s",message);
  149.  else if(type & ERR_IND_RAN)
  150.    sprintf(tkbuffer,"ERROR: index out of range to %s",message);
  151.  else if(type & ERR_NFIL)
  152.    sprintf(tkbuffer,"ERROR: could not open file %s",message);
  153.  else if(type & ERR_NSYM)
  154.    strcat(tkbuffer," must be a symbol");
  155.  else if(type & ERR_NINT)
  156.    strcat(tkbuffer," must be an integer");
  157.  else if(type & ERR_NPRO)
  158.    strcat(tkbuffer," must be a procedure");
  159.  else if(type & ERR_NNUM)
  160.    strcat(tkbuffer," must be a number");
  161.  else if(type & ERR_NENV)
  162.    strcat(tkbuffer," must be an environment");
  163.  else if(type & ERR_NPOR)
  164.    strcat(tkbuffer," must be a port");
  165.  else if(type & ERR_NPAI)
  166.    strcat(tkbuffer," must be a pair");
  167.  else if(type & ERR_NCHA)
  168.    strcat(tkbuffer," must be a character");
  169.  else if(type & ERR_NSTR)
  170.    strcat(tkbuffer," must be a string");
  171.  else if(type & ERR_NVEC)
  172.    strcat(tkbuffer," must be a vector");
  173.  else
  174.    sprintf(tkbuffer,"ERROR: type %d message: %s",type,message);
  175.  if (errjmp_ok == 1) 
  176.   {strncpy(SNAME(sym_err_string),tkbuffer,128);
  177.    setv(sym_errobj,x);
  178.    setv(cintern("*lasterr*"),sym_err_string);
  179.    setv(cintern("*cargs*"),cur_exp);
  180.    setv(cintern("*cenv*"),cur_env);
  181.    apply_proc(VCELL(sym_err_han),NIL,NIL);
  182.    setv(cintern("*cargs*"),NIL);
  183.    setv(cintern("*cenv*"),NIL);
  184.    longjmp(errjmp,1);}
  185.  if((heap==NULL)||(obarray==NULL)||(fixarray==NULL)||(chararray==NULL))
  186.     fprintf(stderr,"Suggested heap or symbol table size too large\n",tkbuffer);
  187.  else
  188.    {fprintf(stderr,"%s\n",tkbuffer);
  189.     fprintf(stderr,"FATAL ERROR\n");}
  190.  exit(20);}
  191.  
  192. LISP error_han(void)
  193. {FILE *out;
  194.  if(NPORTP(cdr(val_output_port)))
  195.    {if(PORTP(VCELL(sym_standard_output)))
  196.       CDR(val_output_port) = VCELL(sym_standard_output);
  197.     else
  198.       {fprintf(stderr,"FATAL ERROR: wrong standard output\n");
  199.        exit(10);}}
  200.  if(NPORTP(cdr(val_input_port)))
  201.    {if(PORTP(VCELL(sym_standard_input)))
  202.       CDR(val_input_port) = VCELL(sym_standard_input);
  203.     else
  204.       {fprintf(stderr,"FATAL ERROR: wrong standard input\n");
  205.        exit(10);}}
  206.  out = PORTPTR(CDR(val_output_port));
  207.  clearerr(out);
  208.  clearerr(PORTPTR(CDR(val_input_port)));
  209.  fflush(NULL);
  210.  fput_st(out,SNAME(sym_err_string));
  211.  fput_st(out,(NULLP(VCELL(sym_errobj)) ? "\n" : " (see errobj)\n"));
  212.  if(VCELL(sym_debug_mode)==truth)
  213.     apply_proc(VCELL(sym_inspect),NIL,NIL);
  214.  return(NIL);}
  215.  
  216. LISP lerr(LISP args)
  217. {LISP message,irritant;
  218.  message=car(args);
  219.  irritant=cdr(args);
  220.  if (NSTRINGP(message)) err("error",message,ERR_GEN_ARG | ERR_NSTR);
  221.  if NULLP(cdr(irritant))
  222.    err(SNAME(message),car(irritant),ERR_GEN);
  223.  err(SNAME(message),irritant,ERR_GEN);
  224.  return(NIL);}
  225.  
  226.